home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 2 / CU Amiga Magazine's Super CD-ROM 02 (1996)(EMAP Images)(GB)[!][issue 1996-04].iso / magazine / amiga_e / jrh-rkrm-partone / intuition / boopsi / rkmbutclass.e < prev    next >
Text File  |  1995-03-31  |  12KB  |  346 lines
  1. -> RKMButClass.e - Example Boopsi gadget for RKRM:Libraries
  2.  
  3. OPT PREPROCESS
  4.  
  5. MODULE 'utility',
  6.        'amigalib/boopsi',
  7.        'tools/installhook',
  8.        'devices/inputevent',
  9.        'graphics/rastport',
  10.        'intuition/cghooks',
  11.        'intuition/classes',
  12.        'intuition/classusr',
  13.        'intuition/gadgetclass',
  14.        'intuition/icclass',
  15.        'intuition/imageclass',
  16.        'intuition/intuition',
  17.        'intuition/screens',
  18.        'utility/tagitem'
  19.  
  20. ENUM ERR_NONE, ERR_LIB, ERR_WIN
  21.  
  22. RAISE ERR_LIB IF OpenLibrary()=NIL,
  23.       ERR_WIN IF OpenWindowTagList()=NIL
  24.  
  25. OBJECT butINST
  26.   midX, midY  -> Coordinates of middle of gadget
  27. ENDOBJECT
  28.  
  29. CONST RKMBUT_PULSE=TAG_USER+1,
  30.       -> butINST has one flag:
  31.       ERASE_ONLY=1, -> Tells rendering routine to only erase the gadget, not
  32.                     -> rerender a new one.  This lets the gadget erase itself
  33.                     -> before it rescales.
  34.       INTWIDTH=40, INTHEIGHT=20
  35.  
  36. DEF w=NIL:PTR TO window, rkmbutcl=NIL,
  37.     integer=NIL:PTR TO gadget, but=NIL:PTR TO gadget
  38.  
  39. -> The main() function connects an rkmButClass object to a Boopsi integer
  40. -> gadget, which displays the rkmButClass gadget's RKMBUT_PULSE value.  The
  41. -> code scales and move the gadget while it is in place.
  42. PROC main() HANDLE
  43.   utilitybase:=OpenLibrary('utility.library', 37)
  44.   w:=OpenWindowTagList(NIL,
  45.                       [WA_FLAGS,  WFLG_DEPTHGADGET OR WFLG_DRAGBAR OR
  46.                                       WFLG_CLOSEGADGET OR WFLG_SIZEGADGET,
  47.                        WA_IDCMP,  IDCMP_CLOSEWINDOW,
  48.                        WA_WIDTH,  640,
  49.                        WA_HEIGHT, 200,
  50.                        NIL])
  51.   WindowLimits(w, 450, 200, 640, 200)
  52.   IF rkmbutcl:=initRKMButGadClass()
  53.     integer:=NewObjectA(NIL, 'strgclass',
  54.                        [GA_ID,            1,
  55.                         GA_TOP,           w.bordertop+5,
  56.                         GA_LEFT,          w.borderleft+5,
  57.                         GA_WIDTH,         INTWIDTH,
  58.                         GA_HEIGHT,        INTHEIGHT,
  59.                         STRINGA_LONGVAL,  0,
  60.                         STRINGA_MAXCHARS, 5,
  61.                         NIL])
  62.     but:=NewObjectA(rkmbutcl, NIL,
  63.                    [GA_ID,            2,
  64.                     GA_TOP,           w.bordertop+5,
  65.                     GA_LEFT,          integer.leftedge+integer.width+5,
  66.                     GA_WIDTH,         INTWIDTH,
  67.                     GA_HEIGHT,        INTHEIGHT,
  68.                     GA_PREVIOUS,      integer,
  69.                     ICA_MAP,         [RKMBUT_PULSE, STRINGA_LONGVAL, NIL],
  70.                     ICA_TARGET,       integer,
  71.                     NIL])
  72.  
  73.     AddGList(w, integer, -1, -1, NIL)
  74.     RefreshGList(integer, w, NIL, -1)
  75.  
  76.     SetWindowTitles(w, '<-- Click to resize gadget Height', NIL)
  77.     mainLoop(NIL, 0)
  78.  
  79.     SetWindowTitles(w, '<-- Click to resize gadget Width', NIL)
  80.     mainLoop(GA_HEIGHT, 100)
  81.  
  82.     SetWindowTitles(w, '<-- Click to resize gadget Y position', NIL)
  83.     mainLoop(GA_WIDTH, 100)
  84.  
  85.     SetWindowTitles(w, '<-- Click to resize gadget X position', NIL)
  86.     mainLoop(GA_TOP, but.topedge+20)
  87.  
  88.     SetWindowTitles(w, '<-- Click to quit', NIL)
  89.     mainLoop(GA_LEFT, but.leftedge+20)
  90.  
  91.     RemoveGList(w, integer, -1)
  92.   ENDIF
  93. EXCEPT DO
  94.   IF but THEN DisposeObject(but)
  95.   IF integer THEN DisposeObject(integer)
  96.   IF rkmbutcl THEN freeRKMButGadClass(rkmbutcl)
  97.   IF w THEN CloseWindow(w)
  98.   IF utilitybase THEN CloseLibrary(utilitybase)
  99.   SELECT exception
  100.   CASE ERR_LIB; WriteF('Error: Could not open utility.library\n')
  101.   CASE ERR_WIN; WriteF('Error: Could not open window\n')
  102.   ENDSELECT
  103. ENDPROC
  104.  
  105. PROC mainLoop(attr, value)
  106.   SetGadgetAttrsA(but, w, NIL, [attr, value, NIL])
  107.   REPEAT
  108.   UNTIL WaitIMessage(w)=IDCMP_CLOSEWINDOW
  109. ENDPROC
  110.  
  111. -> Make the class and set up the dispatcher's hook
  112. PROC initRKMButGadClass()
  113.   DEF cl:PTR TO iclass
  114.   IF cl:=MakeClass(NIL, 'gadgetclass', NIL, SIZEOF butINST, 0)
  115.     -> Initialise the dispatcher Hook.
  116.     -> E-Note: use installhook to set up the hook
  117.     installhook(cl.dispatcher, {dispatchRKMButGad})
  118.   ENDIF
  119. ENDPROC cl
  120.  
  121. -> Free the class
  122. PROC freeRKMButGadClass(cl) IS FreeClass(cl)
  123.  
  124. -> The RKMBut class dispatcher
  125. PROC dispatchRKMButGad(cl:PTR TO iclass, o, msg:PTR TO msg)
  126.   DEF inst:PTR TO butINST, retval=FALSE, g:PTR TO gadget, gpi:PTR TO gpinput,
  127.       ie:PTR TO inputevent, rp, x, y, w, h, tmp, gpmsg:gprender
  128.   -> E-Note: installhook makes sure A4 is set-up properly
  129.   tmp:=msg.methodid
  130.   SELECT tmp
  131.   CASE OM_NEW  -> First, pass up to superclass
  132.     IF g:=doSuperMethodA(cl, o, msg)
  133.       -> Initialise local instance data
  134.       inst:=INST_DATA(cl, g)
  135.       inst.midX:=g.leftedge+(g.width/2)
  136.       inst.midY:=g.topedge+(g.height/2)
  137.       retval:=g
  138.     ENDIF
  139.   CASE GM_HITTEST  -> Since this is a rectangular gadget this
  140.                    -> method always returns GMR_GADGETHIT.
  141.     retval:=GMR_GADGETHIT
  142.   CASE GM_GOACTIVE
  143.     inst:=INST_DATA(cl, o)
  144.  
  145.     -> Only become active if the GM_GOACTIVE was triggered by direct user input.
  146.     IF msg::gpinput.ievent
  147.       -> This gadget is now active, change visual state to selected and render.
  148.       g:=o
  149.       g.flags:=g.flags OR GFLG_SELECTED
  150.       renderRKMBut(cl, o, msg)
  151.       retval:=GMR_MEACTIVE
  152.     ELSE
  153.       -> The GM_GOACTIVE was not triggered by direct user input.
  154.       retval:=GMR_NOREUSE
  155.     ENDIF
  156.   CASE GM_RENDER
  157.     retval:=renderRKMBut(cl, o, msg)
  158.   CASE GM_HANDLEINPUT
  159.     -> While it is active, this gadget sends its superclass an OM_NOTIFY pulse
  160.     -> for every IECLASS_TIMER event that goes by (about one every 10th of a
  161.     -> second).  Any object that is connected to this gadget will get A LOT of
  162.     -> OM_UPDATE messages.
  163.     g:=o
  164.     gpi:=msg
  165.     ie:=gpi.ievent
  166.  
  167.     inst:=INST_DATA(cl, o)
  168.  
  169.     retval:=GMR_MEACTIVE
  170.  
  171.     IF ie.class=IECLASS_RAWMOUSE
  172.       tmp:=ie.code
  173.       SELECT tmp
  174.       CASE SELECTUP
  175.         -> The user let go of the gadget so return GMR_NOREUSE to deactivate
  176.         -> and to tell Intuition not to reuse this Input Event as we have
  177.         -> already processed it. If the user let go of the gadget while the
  178.         -> mouse was over it, mask GMR_VERIFY into the return value so Intuition
  179.         -> will send a Release Verify (GADGETUP).
  180.         IF (gpi.mousex < g.leftedge) OR
  181.            (gpi.mousex > (g.leftedge+g.width)) OR
  182.            (gpi.mousey < g.topedge) OR
  183.            (gpi.mousey > (g.topedge+g.height))
  184.           retval:=GMR_NOREUSE OR GMR_VERIFY
  185.         ELSE
  186.           retval:=GMR_NOREUSE
  187.         ENDIF
  188.  
  189.         -> Since the gadget is going inactive, send a final notification to
  190.         -> the ICA_TARGET.
  191.         notifyPulse(cl, o, 0, inst.midX, msg)
  192.       CASE MENUDOWN
  193.         -> The user hit the menu button. Go inactive and let Intuition reuse
  194.         -> the menu button event so Intuition can pop up the menu bar.
  195.         retval:=GMR_REUSE
  196.  
  197.         -> Since the gadget is going inactive, send a final notification to
  198.         -> the ICA_TARGET.
  199.         notifyPulse(cl, o, 0, inst.midX, msg)
  200.       DEFAULT
  201.         retval:=GMR_MEACTIVE
  202.       ENDSELECT
  203.     ELSEIF ie.class=IECLASS_TIMER
  204.       -> If the gadget gets a timer event, it sends an interim OM_NOTIFY to
  205.       -> its superclass.
  206.       notifyPulse(cl, o, OPUF_INTERIM, inst.midX, gpi)
  207.     ENDIF
  208.   CASE GM_GOINACTIVE
  209.     -> Intuition said to go inactive.  Clear the GFLG_SELECTED bit and render
  210.     -> using unselected imagery.
  211.     g:=o
  212.     g.flags:=g.flags AND Not(GFLG_SELECTED)
  213.     renderRKMBut(cl, o, msg)
  214.   CASE OM_SET
  215.     -> Although this class doesn't have settable attributes, this gadget class
  216.     -> does have scaleable imagery, so it needs to find out when its size and/or
  217.     -> position has changed so it can erase itself, THEN scale, and rerender.
  218.     IF FindTagItem(GA_WIDTH,  msg::opset.attrlist) OR
  219.        FindTagItem(GA_HEIGHT, msg::opset.attrlist) OR
  220.        FindTagItem(GA_TOP,    msg::opset.attrlist) OR
  221.        FindTagItem(GA_LEFT,   msg::opset.attrlist)
  222.       g:=o
  223.  
  224.       x:=g.leftedge
  225.       y:=g.topedge
  226.       w:=g.width
  227.       h:=g.height
  228.  
  229.       inst:=INST_DATA(cl, o)
  230.  
  231.       retval:=doSuperMethodA(cl, o, msg)
  232.  
  233.       -> Get pointer to RastPort for gadget.
  234.       IF rp:=ObtainGIRPort(msg::opset.ginfo)
  235.         SetAPen(rp, msg::opset.ginfo.drinfo.pens[BACKGROUNDPEN])
  236.         SetDrMd(rp, RP_JAM1)  -> Erase the old gadget.
  237.         RectFill(rp, x, y, x+w, y+h)
  238.         inst.midX:=g.leftedge+(g.width/2)  -> Recalculate where the
  239.         inst.midY:=g.topedge+(g.height/2)  -> center of the gadget is.
  240.  
  241.         -> Rerender the gadget.
  242.         -> E-Note: Intuition may alter the message, so don't use a static list
  243.         gpmsg.methodid:=GM_RENDER
  244.         gpmsg.ginfo:=msg::opset.ginfo
  245.         gpmsg.rport:=rp
  246.         gpmsg.redraw:=GREDRAW_REDRAW
  247.         doMethodA(o, gpmsg)
  248.         ReleaseGIRPort(rp)
  249.       ENDIF
  250.     ELSE
  251.       retval:=doSuperMethodA(cl, o, msg)
  252.     ENDIF
  253.   DEFAULT
  254.     -> rkmmodelclass does not recognise the methodID, let the superclass's
  255.     -> dispatcher take a look at it.
  256.     retval:=doSuperMethodA(cl, o, msg)
  257.   ENDSELECT
  258. ENDPROC retval
  259.  
  260. -> Build an OM_NOTIFY message for RKMBUT_PULSE and send it to the superclass.
  261. PROC notifyPulse(cl, o:PTR TO gadget, flags, mid, gpi:PTR TO gpinput)
  262.   DEF msg:PTR TO opnotify  -> E-Note: "opnotify" is really "opupdate"
  263.   -> If this is an OM_UPDATE method, make sure the part the OM_UPDATE message
  264.   -> adds to the OM_SET message gets added.  That lets the dispatcher handle
  265.   -> OM_UPDATE and OM_SET in the same case.
  266.   msg:=[OM_NOTIFY, [RKMBUT_PULSE, mid-(gpi.mousex+o.leftedge),
  267.                     GA_ID, o.gadgetid, NIL],
  268.         gpi.ginfo, flags]:opnotify
  269.  
  270.   -> E-Note: A bug (?) in Intuition means that the methodid of an OM_NOTIFY
  271.   ->         message may be altered, so you can't get away with just using a
  272.   ->         constant value in the above static list...
  273.   msg.methodid:=OM_NOTIFY
  274.  
  275.   doSuperMethodA(cl, o, msg)
  276. ENDPROC
  277.  
  278. -> Erase and rerender the gadget.
  279. PROC renderRKMBut(cl:PTR TO iclass, g:PTR TO gadget, msg:PTR TO gprender)
  280.   DEF inst:PTR TO butINST, rp, retval=TRUE, pens:PTR TO INT,
  281.       back, shine, shadow, w, h, x, y
  282.   inst:=INST_DATA(cl, g)
  283.   pens:=msg.ginfo.drinfo.pens
  284.  
  285.   IF msg.methodid=GM_RENDER
  286.     -> If msg is truly a GM_RENDER message (not a gpinput that looks like a
  287.     -> gprender), use the rastport within it...
  288.     rp:=msg.rport
  289.   ELSE  -> ...Otherwise, get a rastport using ObtainGIRPort().
  290.     rp:=ObtainGIRPort(msg.ginfo)
  291.   ENDIF
  292.  
  293.   IF rp
  294.     IF g.flags AND GFLG_SELECTED
  295.       -> If the gadget is selected, reverse the meanings of the pens.
  296.       back:=pens[FILLPEN]
  297.       shine:=pens[SHADOWPEN]
  298.       shadow:=pens[SHINEPEN]
  299.     ELSE
  300.       back:=pens[BACKGROUNDPEN]
  301.       shine:=pens[SHINEPEN]
  302.       shadow:=pens[SHADOWPEN]
  303.     ENDIF
  304.     SetDrMd(rp, RP_JAM1)
  305.  
  306.     SetAPen(rp, back)  -> Erase the old gadget.
  307.     RectFill(rp, g.leftedge,         g.topedge,
  308.                  g.leftedge+g.width, g.topedge+g.height)
  309.  
  310.     SetAPen(rp, shadow)  -> Draw shadow edge.
  311.     Move(rp, g.leftedge+1, g.topedge+g.height)
  312.     Draw(rp, g.leftedge+g.width, g.topedge+g.height)
  313.     Draw(rp, g.leftedge+g.width, g.topedge+1)
  314.  
  315.     w:=g.width/4   -> Draw Arrows - Sorry, no frills imagery
  316.     h:=g.height/2
  317.     x:=g.leftedge+(w/2)
  318.     y:=g.topedge+(h/2)
  319.  
  320.     Move(rp, x, inst.midY)
  321.     Draw(rp, x+w, y)
  322.     Draw(rp, x+w, y+g.height-h)
  323.     Draw(rp, x, inst.midY)
  324.  
  325.     x:=g.leftedge+(w/2)+(g.width/2)
  326.  
  327.     Move(rp, x+w, inst.midY)
  328.     Draw(rp, x, y)
  329.     Draw(rp, x, y+g.height-h)
  330.     Draw(rp, x+w, inst.midY)
  331.  
  332.     SetAPen(rp, shine)  -> Draw shine edge.
  333.     Move(rp, g.leftedge, g.topedge+g.height-1)
  334.     Draw(rp, g.leftedge, g.topedge)
  335.     Draw(rp, g.leftedge+g.width-1, g.topedge)
  336.  
  337.     IF msg.methodid<>GM_RENDER  -> If we allocated a rastport, give it back.
  338.       ReleaseGIRPort(rp)
  339.     ENDIF
  340.   ELSE
  341.     retval:=FALSE
  342.   ENDIF
  343. ENDPROC retval
  344.  
  345. vers: CHAR 0, '$VER: TestBut 37.1', 0
  346.